home *** CD-ROM | disk | FTP | other *** search
/ TOS Silver 2000 / TOS Silver 2000.iso / programm / MM2_DEV / S / MOS / GEMIO.I < prev    next >
Encoding:
Modula Implementation  |  1993-06-07  |  10.0 KB  |  429 lines
  1. IMPLEMENTATION MODULE GEMIO;
  2. (*$B+,Y+,S-,R-*)
  3.  
  4. (*
  5.  * Treibermodul.
  6.  *
  7.  * Leitet alle Ein- und Ausgaben von 'InOut' und der Unit 'CON:' auf
  8.  * ein Window von 'TextWindows'.
  9.  *
  10.  * Durch Setzen von 'ConfirmClose' auf TRUE wird erreicht, daß
  11.  * beim Ende des damit gelinkten Programms auf eine Taste gewartet
  12.  * wird, bevor der Fensterinhalt verschwindet.
  13.  *
  14.  * Die Größe des "StdIO"-Fenster, das von 'InOut' erzeugt wird, kann frei
  15.  * gewählt werden, indem die Konstanten 'StdX' und 'StdY' (s.u.) verändert
  16.  * werden. Dann ist dies Modul zu compilieren und ggf. auch die Shell neu
  17.  * zu linken.
  18.  *
  19.  * Näheres siehe Definitions-Text
  20.  *)
  21.  
  22.  
  23. FROM SYSTEM IMPORT WORD, LONGWORD, ADDRESS, CAST, ADR, ASSEMBLER;
  24. IMPORT TextWindows, InOutBase, FileBase;
  25. FROM MOSGlobals IMPORT MemArea, OutOfMemory;
  26. FROM AESForms IMPORT FormAlert;
  27. FROM Strings IMPORT Delete, Concat, Append;
  28. FROM ResCtrl IMPORT RemovalCarrier, CatchRemoval;
  29.  
  30.  
  31. CONST
  32.   StdX = 80;              (* Zeichenbreite des InOut-Fensters *)
  33.   StdY = 25;              (* Zeilenanzahl des InOut-Fensters *)
  34.   ConfirmClose = FALSE;   (* TRUE -> Bei Prg-Ende wird auf Taste gewartet *)
  35.  
  36.  
  37. VAR conOp, ioOp, ok: BOOLEAN;
  38.     waitAtEnd: BOOLEAN;
  39.     opened: CARDINAL;
  40.     window: TextWindows.Window;
  41.  
  42.  
  43. PROCEDURE chkWdw;
  44.   BEGIN
  45.     IF ~ok THEN
  46.       (*
  47.         RaiseError (OutOfMemory,'Kein Fenster mehr frei.',selfCaused,mustAbort)
  48.       *)
  49.       ASSEMBLER
  50.         TRAP    #6
  51.         DC.W    OutOfMemory-$A000
  52.         ACZ     'Kein Fenster mehr frei.'
  53.       END
  54.     END
  55.   END chkWdw;
  56.  
  57. PROCEDURE close;
  58.   VAR c: CHAR;
  59.   BEGIN
  60.     IF opened > 0 THEN
  61.       DEC (opened);
  62.       IF opened = 0 THEN
  63.         IF waitAtEnd & ConfirmClose THEN
  64.           (* Am Programmende auf Tastendruck warten *)
  65.           TextWindows.Read (window, c);
  66.         END;
  67.         TextWindows.Close (window)
  68.       END
  69.     END;
  70.   END close;
  71.  
  72. PROCEDURE ioClose;
  73.   BEGIN
  74.     ioOp:= FALSE;
  75.     IF ~conOp THEN close END;
  76.   END ioClose;
  77.  
  78.  
  79. PROCEDURE open (x,y: CARDINAL);
  80.   BEGIN
  81.     IF opened = 0 THEN
  82.       IF x=0 THEN x:= StdX END;
  83.       IF y=0 THEN y:= StdY END;
  84.       TextWindows.Open (window,x,y,TextWindows.WQualitySet{TextWindows.movable,
  85.                         TextWindows.dynamic,TextWindows.titled},
  86.                         TextWindows.noHideWdw, TextWindows.noForce,
  87.                         'StdIO', -1,-1,-1,-1, ok);
  88.       waitAtEnd:= FALSE;
  89.       chkWdw
  90.     END;
  91.     INC (opened)
  92.   END open;
  93.  
  94. PROCEDURE ioOpen (x,y: CARDINAL);
  95.   BEGIN
  96.     open (x,y);
  97.     ioOp:= TRUE;
  98.   END ioOpen;
  99.  
  100.  
  101. PROCEDURE Read (VAR c:CHAR);
  102.   (*$L-*)
  103.   BEGIN
  104.     ASSEMBLER
  105.         CLR     waitAtEnd       ; waitAtEnd:= FALSE
  106.         MOVE.L  -(A3),D0
  107.         MOVE.L  window,(A3)+
  108.         MOVE.L  D0,(A3)+
  109.         JMP     TextWindows.Read
  110.     END
  111.   END Read;
  112.   (*$L=*)
  113.  
  114. PROCEDURE Write(c:CHAR);
  115.   (*$L-*)
  116.   BEGIN
  117.     ASSEMBLER
  118.         MOVE    #1,waitAtEnd    ; waitAtEnd:= TRUE
  119.         MOVE.W  -(A3),D0
  120.         MOVE.L  window,(A3)+
  121.         MOVE.W  D0,(A3)+
  122.         JMP     TextWindows.Write
  123.     END
  124.   END Write;
  125.   (*$L=*)
  126.  
  127. PROCEDURE CondRead (VAR c:CHAR;VAR b:BOOLEAN);
  128.   (*$L-*)
  129.   BEGIN
  130.     ASSEMBLER
  131.         JMP     TextWindows.CondRead
  132.     END
  133.   END CondRead;
  134.   (*$L=*)
  135.  
  136. PROCEDURE KeyPressed ():BOOLEAN;
  137.   (*$L-*)
  138.   BEGIN
  139.     ASSEMBLER
  140.         JMP     TextWindows.KeyPressed
  141.     END
  142.   END KeyPressed;
  143.   (*$L=*)
  144.  
  145. PROCEDURE WriteLn;
  146.   (*$L-*)
  147.   BEGIN
  148.     ASSEMBLER
  149.         MOVE.L  window,(A3)+
  150.         JMP     TextWindows.WriteLn
  151.     END
  152.   END WriteLn;
  153.   (*$L=*)
  154.  
  155. PROCEDURE WritePg;
  156.   (*$L-*)
  157.   BEGIN
  158.     ASSEMBLER
  159.         MOVE.L  window,(A3)+
  160.         JMP     TextWindows.WritePg
  161.     END
  162.   END WritePg;
  163.   (*$L=*)
  164.  
  165. PROCEDURE GotoXY (x,y:CARDINAL);
  166.   (*$L-*)
  167.   BEGIN
  168.     ASSEMBLER
  169.         MOVE.L  -(A3),D0
  170.         MOVE.L  window,(A3)+
  171.         MOVE.L  D0,(A3)+
  172.         JMP     TextWindows.GotoXY
  173.     END
  174.   END GotoXY;
  175.   (*$L=*)
  176.  
  177. PROCEDURE ReadString (VAR c:ARRAY OF CHAR);
  178.   (*$L-*)
  179.   BEGIN
  180.     ASSEMBLER
  181.         CLR     waitAtEnd       ; waitAtEnd:= FALSE
  182.         MOVE.W  -(A3),D1
  183.         MOVE.L  -(A3),D0
  184.         MOVE.L  window,(A3)+
  185.         MOVE.L  D0,(A3)+
  186.         MOVE.W  D1,(A3)+
  187.         JSR     TextWindows.ReadString
  188.         MOVE.L  window,(A3)+
  189.         JMP     TextWindows.WriteLn
  190.     END
  191.   END ReadString;
  192.   (*$L=*)
  193.  
  194. PROCEDURE WriteString (REF c:ARRAY OF CHAR);
  195.   (*$L-*)
  196.   BEGIN
  197.     ASSEMBLER
  198.         MOVE    #1,waitAtEnd    ; waitAtEnd:= TRUE
  199.         MOVE.W  -(A3),D1
  200.         MOVE.L  -(A3),D0
  201.         MOVE.L  window,(A3)+
  202.         MOVE.L  D0,(A3)+
  203.         MOVE.W  D1,(A3)+
  204.         JMP     TextWindows.WriteString
  205.     END
  206.   END WriteString;
  207.   (*$L=*)
  208.  
  209. (*
  210. PROCEDURE openAskWdw ( VAR wdw: TextWindows.Window );
  211.   BEGIN
  212.     TextWindows.Open (wdw,34,7,TextWindows.WQualitySet{TextWindows.titled},
  213.                       TextWindows.noHideWdw,TextWindows.forceCursor,
  214.                       'E/A Umleitung', -1,-1,-1,-1, ok);
  215.     chkWdw
  216.   END openAskWdw;
  217. *)
  218.  
  219. PROCEDURE GetInput ( VAR name: ARRAY OF CHAR );
  220.   VAR wdw: TextWindows.Window;
  221.   BEGIN
  222.     (*
  223.       openAskWdw (wdw);
  224.       TextWindows.WriteString (wdw, 'Eingabedatei:');
  225.       TextWindows.WriteLn (wdw);
  226.       TextWindows.Write (wdw, '<');
  227.     *)
  228.     ReadString (name);
  229.     (*
  230.       TextWindows.Close (wdw)
  231.     *)
  232.   END GetInput;
  233.  
  234. PROCEDURE GetOutput ( VAR name: ARRAY OF CHAR; VAR append: BOOLEAN );
  235.   VAR wdw: TextWindows.Window;
  236.   BEGIN
  237.     (*
  238.       openAskWdw (wdw);
  239.       TextWindows.WriteString (wdw, 'Ausgabedatei:');
  240.       TextWindows.WriteLn (wdw);
  241.       TextWindows.Write (wdw, '>');
  242.     *)
  243.     ReadString (name);
  244.     append:= name[0] = '>';
  245.     IF append THEN
  246.       Delete (name,0,1,ok)
  247.     END;
  248.     (*
  249.       TextWindows.Close (wdw)
  250.     *)
  251.   END GetOutput;
  252.  
  253. PROCEDURE OpenError ( VAR msg: ARRAY OF CHAR; VAR retry: BOOLEAN );
  254.   VAR txt: ARRAY [0..89] OF CHAR;
  255.       but: CARDINAL;
  256.   BEGIN
  257.     Concat ('[0][Fehler beim Öffnen:|',msg,txt,ok);
  258.     Append ('|Nochmalige Eingabe ?][ Ja |Nein]',txt,ok);
  259.     FormAlert (1,txt,but);
  260.     retry:= but=1
  261.   END OpenError;
  262.  
  263. PROCEDURE IOError ( VAR msg: ARRAY OF CHAR; input: BOOLEAN );
  264.   VAR txt: ARRAY [0..99] OF CHAR;
  265.       but: CARDINAL;
  266.   BEGIN
  267.     txt:= '[0][Fehler bei Datei';
  268.     IF input THEN
  269.       Append ('eingabe:|',txt,ok)
  270.     ELSE
  271.       Append ('ausgabe:|',txt,ok)
  272.     END;
  273.     Append (msg,txt,ok);
  274.     Append ('|Datei wird geschlossen][ OK ]',txt,ok);
  275.     FormAlert (1,txt,but)
  276.   END IOError;
  277.  
  278.  
  279. PROCEDURE conOpen (VAR hdl:LONGWORD; name: ARRAY OF CHAR): INTEGER;
  280.   BEGIN
  281.     open (80,25);
  282.     conOp:= TRUE;
  283.     hdl:= CAST (LONGWORD,window);
  284.     RETURN 0
  285.   END conOpen;
  286.  
  287. PROCEDURE conClose (hdl:LONGWORD): INTEGER;
  288.   BEGIN
  289.     conOp:= FALSE;
  290.     IF ~ioOp THEN close END;
  291.     RETURN 0
  292.   END conClose;
  293.  
  294. PROCEDURE conOut ( hdl: LONGWORD; ad:ADDRESS; VAR l:LONGCARD ): INTEGER;
  295.   (*$L-*)
  296.   BEGIN
  297.     ASSEMBLER
  298.         MOVE.L  -(A3),A0
  299.         MOVE.L  (A0),D0
  300.         BEQ     e0
  301.         ; mehr als 64 KB Text wird's wohl nicht sein...
  302.         SUBQ    #1,D0
  303.         MOVE    D0,(A3)+
  304.         JSR     TextWindows.WriteString
  305.         CLR     (A3)+           ; RETURN 0
  306.         RTS
  307.     e0  SUBQ.L  #8,A3
  308.         CLR     (A3)+           ; RETURN 0
  309.     END
  310.   END conOut;
  311.   (*$L=*)
  312.  
  313.  
  314. PROCEDURE conStrOut ( hdl: LONGWORD; REF str: ARRAY OF CHAR ): INTEGER;
  315.   (*$L-*)
  316.   BEGIN
  317.     ASSEMBLER
  318.         JSR     TextWindows.WriteString
  319.         CLR     (A3)+           ; RETURN 0
  320.     END
  321.   END conStrOut;
  322.   (*$L=*)
  323.  
  324.  
  325. PROCEDURE conIn ( hdl: LONGWORD; ad:ADDRESS; VAR l:LONGCARD ): INTEGER;
  326.   (*$L-*)
  327.   BEGIN
  328.     ASSEMBLER
  329.         MOVEM.L D4/A4,-(A7)
  330.         MOVE.L  -(A3),A0
  331.         MOVE.L  (A0),D4
  332.         MOVE.L  -(A3),A4
  333.         SUBQ.L  #4,A3
  334.         BRA     st
  335.        lo:
  336.         MOVE.L  A4,(A3)+
  337.         CLR     -(A7)
  338.         MOVE.L  A7,(A3)+
  339.         JSR     TextWindows.CondRead
  340.         TST     (A7)+
  341.         BEQ     lo
  342.        st:
  343.         DBRA    D4,lo
  344.         MOVEM.L (A7)+,D4/A4
  345.         CLR     (A3)+
  346.     END
  347.   END conIn;
  348.   (*$L=*)
  349.  
  350. PROCEDURE conCIn ( hdl: LONGWORD ): INTEGER;
  351.   (*$L-*)
  352.   BEGIN
  353.     ASSEMBLER
  354.         SUBQ.L  #4,A3
  355.         CLR     -(A7)
  356.        lo:
  357.         MOVE.L  A7,(A3)+
  358.         CLR     -(A7)
  359.         MOVE.L  A7,(A3)+
  360.         JSR     TextWindows.CondRead
  361.         TST     (A7)+
  362.         BEQ     lo
  363.         MOVEQ   #0,D0
  364.         MOVE.B  (A7)+,D0
  365.         MOVE    D0,(A3)+
  366.     END
  367.   END conCIn;
  368.   (*$L=*)
  369.  
  370.  
  371. VAR pbuf: ARRAY [0..14] OF LONGWORD; pidx: CARDINAL;
  372.  
  373. PROCEDURE pset (f:BOOLEAN);
  374.   PROCEDURE pswap (VAR l:LONGWORD; v:LONGWORD);
  375.     (*$R+*)
  376.     BEGIN
  377.       IF f THEN pbuf [pidx]:= l; l:= v ELSE l:= pbuf [pidx] END;
  378.       INC (pidx)
  379.     END pswap;
  380.     (*$R=*)
  381.   BEGIN
  382.     pidx:= 0;
  383.     pswap (InOutBase.Read, Read);
  384.     pswap (InOutBase.Write, Write);
  385.     pswap (InOutBase.OpenWdw, ioOpen);
  386.     pswap (InOutBase.CloseWdw, ioClose);
  387.     pswap (InOutBase.KeyPressed, KeyPressed);
  388.     pswap (InOutBase.CondRead, CondRead);
  389.     pswap (InOutBase.WriteLn, WriteLn);
  390.     pswap (InOutBase.WritePg, WritePg);
  391.     pswap (InOutBase.WriteString, WriteString);
  392.     pswap (InOutBase.ReadString, ReadString);
  393.     pswap (InOutBase.GotoXY, GotoXY);
  394.     pswap (InOutBase.GetInput, GetInput);
  395.     pswap (InOutBase.GetOutput, GetOutput);
  396.     pswap (InOutBase.OpenError, OpenError);
  397.     pswap (InOutBase.IOError, IOError)
  398.   END pset;
  399.  
  400. PROCEDURE restore;
  401.   BEGIN
  402.     pset (FALSE) (* Wiederherstellen der alten PROC-Werte *)
  403.   END restore;
  404.  
  405. VAR tc: RemovalCarrier; st: MemArea;
  406.  
  407. BEGIN
  408.   opened:= 0;
  409.   CatchRemoval (tc, restore, st);
  410.   pset (TRUE);  (* Retten der alten PROC-Werte und Setzen der Neuen *)
  411.  
  412.   (*** Einrichten der Unit 'CON:' als Window ***)
  413.   WITH FileBase.UnitDriver [FileBase.con] DO
  414.     (* Übernahme der Standard-Einstellungen (FileBase):
  415.       valid:= TRUE;
  416.       name:= 'CON:';
  417.       input:= TRUE;
  418.       output:= TRUE;
  419.     *)
  420.     initHdl:= CAST (LONGWORD, NIL);
  421.     open:= conOpen;
  422.     close:= conClose;
  423.     wrData:= conOut;
  424.     rdData:= conIn;
  425.     wrStr:= conStrOut;
  426.     rdChr:= conCIn;
  427.   END;
  428. END GEMIO.
  429.